Chip 2000 November/Chip Kasım 2000.iso/prog/share/11/setup.exe/%MAINDIR%/DEMOS/CIHTTP/HTTPEXP/callback.cls

Visual Basic class definition | 2000-09-07 | 8.3 KB | 252 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "HTTPCallback"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'----------------------------------------------------
'<Purpose> callback function to show the HTTPServer
' anchors in the TreeView
'----------------------------------------------------
Public Function ShowAnchors(ThisSession As Form, ThisExplorer As Form, ServerNode As Node)
    Dim i               As Integer
    Dim ListCount       As Integer
    Dim TypeAnchor      As Integer
    Dim TheseItems      As ListItems
    Dim WorkingItem     As ListItem
    Dim TheseNodes      As Nodes
    Dim WorkingNode     As Node
    Dim FullPathName    As String
    Dim ListItem        As String
    Dim NodeKey         As String
    Dim ServerKey       As String
    Dim SiteName        As String
    'Dim Temp            As String
    Dim WorkingDir      As String

    ServerKey = ServerNode.Key

    '---- cache explorer objects
    Set TheseNodes = ThisExplorer.Tree.Nodes
    Set TheseItems = ThisExplorer.List.ListItems

    WorkingDir = ThisSession.WorkingDir
    SiteName = ThisSession.WWWSiteName

    '---- add all anchors and create extra data for each
    With ThisSession
        ListCount = .lstAnchors.ListCount - 1
        For i = 0 To ListCount
            ListItem = .lstAnchors.List(i)
            TypeAnchor = AnchorType(ListItem)
            If (TypeAnchor <> refFTPServer) Then

                '---- get the full path to a URL
                FullPathName = PrepareURL(ListItem, ServerNode)

                'NodeKey = ServerKey & "." & ListItem
                NodeKey = ServerKey & "." & FullPathName
                If (ListItem = "") Then GoTo NextItem   '---- seen it happen
                If (Not (TypeAnchor = refWebPage)) Then '---- pages are only displayed in the list
                    If (Not IsKeyed(TheseNodes, NodeKey)) Then

                        On Error GoTo DuplicateItem
                        '---- add extra data
                        Dim ThisAttachment As New Attachment
                        ThisAttachment.NodeType = nodHTTPFolder
                        ThisAttachment.DrivePath = FullPathName
                        Set ThisAttachment.Session = ThisSession
                        Call ThisExplorer.Attachments.Add(ThisAttachment, NodeKey)
                        Set ThisAttachment = Nothing
                        On Error GoTo 0

                        Set WorkingNode = TheseNodes.Add(ServerNode, tvwChild, NodeKey, ListItem, imgHTTPLink, imgHTTPLinkOpen)

                        '---- add searching placeholder
                        Call TheseNodes.Add(WorkingNode, tvwChild, WorkingNode.Key & nodPlaceHolder, nodPlaceHolder, imgPlaceHolder)
                    End If
                End If

                On Error GoTo DuplicateItem

                '---- add anchor to ListView; pad with invisible char for sorting purposes
                If (TypeAnchor = refWebPage) Then
                    '<Launch Web Page>
                    '---- special concatenator so parent key can be easily parsed
                    Set WorkingItem = TheseItems.Add(, ServerKey & "~" & FullPathName, ListItem, imgHTTPFile, imgHTTPFile)
                    WorkingItem.SubItems(2) = "Web Page"
                    '<Launch Web Page>
                Else
                    Set WorkingItem = TheseItems.Add(, NodeKey, Chr(160) & ListItem, imgHTTPLink, imgHTTPLink)
                    WorkingItem.SubItems(2) = "Web Directory Link"
                End If

                On Error GoTo 0
            End If
NextItem:
        Next
    End With

Cleanup:
    Set TheseItems = Nothing
    Set TheseNodes = Nothing
    Set WorkingNode = Nothing
    Set WorkingItem = Nothing
    Exit Function

DuplicateItem:
    Resume NextItem

End Function


'---------------------------------------------------------------
'<Purpose> checks an anchor to see if does not refer to an
' FTP anchor
'---------------------------------------------------------------
Private Function AnchorType(ThisAnchor As String) As Integer
    Dim CharPos As Integer

    '---- check to see if it has a page extension
    CharPos = InStr(UCase(ThisAnchor), ".HTM")
    If (CharPos > 0) Then
        AnchorType = refWebPage
        Exit Function
    End If

    '---- ftp server reference
    CharPos = InStr(UCase(ThisAnchor), "FTP://")
    If (CharPos > 0) Then
        AnchorType = refFTPServer
        Exit Function
    End If

    '---- http server reference
    CharPos = InStr(UCase(ThisAnchor), "HTTP://")
    If (CharPos > 0) Then
        AnchorType = refHTTPServer
        Exit Function
    End If

    If (left(ThisAnchor, 1) = "/") Then
        AnchorType = refFullPath
        Exit Function
    End If

    If (left(ThisAnchor, 3) = "../") Then
        AnchorType = refDownPath
        Exit Function
    End If

    If (left(ThisAnchor, 1) <> "/") Then
        AnchorType = refUpPath
        Exit Function
    End If

    AnchorType = refUnkown

End Function

'---------------------------------------------------------------
'<Purpose> returns the last portion of an HTTP anchor;
' also returns if the item is a directory or page anchor
'---------------------------------------------------------------
Private Function ParseAnchor(ThisItem As String, IsPage As Boolean) As String
    Dim CharPos As Integer
    Dim Temp    As String

    Temp = ThisItem
    Do
        CharPos = InStr(Temp, "/")
        If (CharPos = 0) Then Exit Do
        If (CharPos = Len(Temp)) Then
            Temp = left(Temp, Len(Temp) - 1)
            Exit Do
        End If
        Temp = Mid(Temp, CharPos + 1)
    Loop

    '---- check to see if it has a page extension
    IsPage = (InStr(UCase(Temp), ".HTM") > 0)

    ParseAnchor = Temp

End Function

'----------------------------------------------------
'<Purpose> prepares a full URL given an item from
' the 'anchors' list and a node
'----------------------------------------------------
Private Function PrepareURL(AnchorItem As String, ServerNode As Node) As String
    Dim ThisAttachment  As New Attachment
    Dim i               As Integer
    Dim CharPos         As Integer
    Dim ThisNode        As Node
    Dim ParentURL       As String
    Dim Temp            As String

    Temp = AnchorItem

    '---- items beginning with slashes should be absolute URLs
    If (left(Temp, 1) = "/") Then
        PrepareURL = Temp
        GoTo Cleanup
    End If

    '---- items beginning with http are absolute URLs
    If (left(LCase(Temp), 7) = "http://") Then
        PrepareURL = Temp
        GoTo Cleanup
    End If

    '---- relative reference
    If (left(Temp, 3) = "../") Then

        Set ThisNode = ServerNode.Parent
        Set ThisAttachment = Explorer.Attachments.Item(ThisNode.Key)
        ParentURL = ThisAttachment.DrivePath

        Do
            Temp = Mid(Temp, 4)

            '---- remove a directory from the parent URL
            For i = Len(ParentURL) - 1 To 1 Step -1
                If (Mid(ParentURL, i, 1) = "/") Then
                    ParentURL = left(ParentURL, i + 1)
                    Exit For
                End If
            Next

            '---- loop for all these types of references
            CharPos = InStr(Temp, "../")
            If (CharPos = 0) Then
                Temp = ParentURL & Temp
                Exit Do
            End If
        Loop

        PrepareURL = Temp
        GoTo Cleanup
    End If

    '---- else relative reference not begginning with slash
    Set ThisNode = ServerNode.Parent
    Set ThisAttachment = Explorer.Attachments.Item(ThisNode.Key)
    ParentURL = ThisAttachment.DrivePath
    If (ParentURL = "") Then
        PrepareURL = "/" & Temp
        GoTo Cleanup
    End If


Cleanup:
    Set ThisNode = Nothing
    Set ThisAttachment = Nothing

End Function